7cad Lisp.lsp
;By Pham Vu Hong Linh - www.7cad-programming.com
;Source Code is copyrighted to Pham Vu Hong Linh at 7cad
;4th-Jan-2016: 1st release
;Version: since 2007
(prompt
"\n-------------------------------------------------------------------")
(prompt
"\n7cad LISP | 11th Apr 2016")
(prompt
"\n-------------------------------------------------------------------\n")
;--------------------------------------------
;1st: initialize things: start custom error handler and undo sequence
(7begin)
;2nd: select objects and run commands
(if (setq ss (ssget))
(l+runCA ss)
)
;3rd: end undo sequence
(7end)
)
;--------------------------------------------
(defun C:RA (/ ss *error*);Copying object to make rotated (polar) array with varies angles
;1st: initialize things: start custom error handler and undo sequence
(7begin)
;2nd: select objects and run commands
(if (setq ss (ssget))
(l+runRA ss)
)
;3rd: end undo sequence
(7end)
)
;--------------------------------------------------------
(defun 7begin (/)
;1st: custom error message to avoid bad-looking native error message:
(defun *error* (msg /)
(prompt " *7cad command cancelled* ")
(7end)
)
;2nd: set OSNAPCOORD variable to 1 to force script commands not to use OSNAP things:
(setvar "osnapcoord" 1)
;3rd: start undo mark
;Make sure undo is fully enabled:
(if (equal 0 (getvar "UNDOCTL"))
(command "_.undo" "_all")
)
(if (or (not (equal 1 (logand 1 (getvar "UNDOCTL"))))
(equal 2 (logand 2 (getvar "UNDOCTL")))
)
(command "_.undo" "_control" "_all")
)
;Ensure undo auto is off:
(if (equal 4 (logand 4 (getvar "undoctl")))
(command "_.undo" "_Auto" "_off")
)
;Place an 7end mark down if needed:
(while (equal 8 (logand 8 (getvar "undoctl")))
(command "_.undo" "_end")
)
;Start new undo group:
(command "_.undo" "_begin")
)
;--------------------------------------------------------
(defun 7end (/)
(if command-s; this is for newer version of AutoCAD
(command-s "_.undo" "_end")
(command "_.undo" "_end")
)
(princ)
)
;--------------------------------------------------------
(defun l+runCA (ss /
basep target
count dirAngle
curdist newdist
)
(if (setq basep (getpoint "\nSelect basepoint: "))
(setq target (getpoint basep "\nSpecify direction point: "))
)
(if target
(setq curdist (distance basep target)
dirAngle (angle basep target)
count 1
)
)
(while (and target
(progn
(initget "eXit Undo")
(/= "eXit"
(setq newdist (getdist
(strcat "\nEnter distance to move [eXit/Undo]:<" (rtos curdist)"><" (itoa count)"> ")
)
)
)
);progn
)
;Input newdist can be a distance, or "Undo" keyword (or "eXit" keyword, which ends this while loop)
(cond
((= "Undo" newdist)
(if (> count 1)
(progn
(command "_.undo" "_back") ;Note: command name and option key prefixed with "_" for compatibility with other language package, e.g. AutoCAD German
(setq count(- count 1))
)
)
)
(T
(if (null newdist)
(setq newdist curdist)
)
(setq curdist newdist
target (polar basep dirAngle curdist)
)
(setq count (1+ count))
(command "_.undo" "_mark")
(command "_.copy" ss "" '(0 0) '(0 0))
(command "_.move" ss "" basep target)
)
)
);while
);defun
;------------------------------------------------------------------------------
(defun l+runRA (ss / origin rotation newrot count)
(setq origin (getpoint "\nSelect base point: ")
rotation 90 ;default rotation
count 1
)
(while (and origin
(progn
(initget "eXit Undo")
(/= "eXit"
(setq newrot (getangle
(strcat "\nEnter rotation [eXit/Undo]:<" (rtos rotation 2)"><" (itoa count)"> ")
)
)
)
);progn
)
;Input newdist can be a distance, or "Undo" keyword (or "7end" keyword, which ends this while loop)
(cond
((= "Undo" newrot)
(if (> count 1)
(progn
(command "_.undo" "_back") ;Note: command name and option key prefixed with "_" for compatibility with other language package, e.g. AutoCAD German
(setq count(- count 1))
)
)
)
(T
(if newrot
(setq newrot (* (/ newrot pi) 180.));convert it from radiant to degree
(setq newrot rotation)
)
(setq rotation newrot)
(setq count (1+ count))
(command "_.undo" "_mark")
(command "_.copy" ss "" '(0 0) '(0 0))
(command "_.rotate" ss "" origin rotation)
)
)
);while
);defun
;---------------------------------------------------------------------------
(defun C:7BRPurlins (/ *error*
purlin ss1
ss2 line
i j el sp1 ep1 sp2 ep2
joint joints
)
;Initialize error handlers, undo sequence, system variables :
(7begin)
;Select:
(prompt "Select purlin lines: ")
(setq ss1 (ssget ":L" '((0 . "LINE")))
j -1
)
;Get offset lapping length:
(if ss1
(progn
(if (null Purlin_L)(setq Purlin_L 500));assuming drawing is in millimeter
(setq newdist (getdist (strcat "\nEnter purlins lapping length <" (rtos Purlin_L) ">: ")))
(if newdist (setq Purlin_L newdist))
)
)
;zoom all first:
(if ss1 (command "_.zoom" "_o" ss1 ""))
;Break each purlin:
(repeat (if ss1 (sslength ss1) 0)
(setq j (1+ j)
purlin (ssname ss1 j)
el (entget purlin)
sp1 (cdr (assoc 10 el))
ep1 (cdr(assoc 11 el))
i -1
;use purlin itself to automatically select beams or columns:
;(remember to zoom in all objects)
ss2 (ssget "_F" (mapcar 'l+transw2c (list sp1 ep1) (list nil nil)) '((0 . "LINE")))
joints nil
)
(repeat (if ss2 (sslength ss2) 0)
(setq i (1+ i)
line (ssname ss2 i)
)
(if (not (equal line purlin))
(progn
(setq el (entget line)
sp2 (cdr(assoc 10 el))
ep2 (cdr(assoc 11 el))
joint (inters sp1 ep1 sp2 ep2)
)
(if joint (setq joints (cons joint joints)))
)
);if
);repeat
(if joints (l+breakPurlin purlin sp1 ep1 joints Purlin_L))
);repeat
(if ss1 (command "_.zoom" "_p"))
;Release error handler and others:
(7end)
)
;--------------------------------
(defun l+breakPurlin (purlin sp1 ep1 joints extension /
el sp ep joint0 joint1
gap
i j
_compare _newline
)
;break it if only it has 3 joints
;otherwise, only adjust the extension
(defun _compare (joint1 joint2 /)
(< (distance sp1 joint1)(distance sp1 joint2))
)
(defun _newline (sp ep /)
(setq el (subst (cons 10 sp) (assoc 10 el) el)
el (subst (cons 11 ep) (assoc 11 el) el)
)
)
(setq joints (vl-sort joints '_compare)
el (entget purlin)
)
;Break the purlin then insert the proper lines
(setq joint0 (car joints)
joint1 (last joints)
sp (polar joint0 (angle ep1 sp1) (* 0.5 extension))
ep (polar joint1 (angle sp1 ep1) (* 0.5 extension))
i 0
)
(entmod (_newline sp ep))
(setq gap (l+dimtextheight)
j -1
)
(if (> (length joints) 2)
(repeat (- (length joints) 1)
(setq i (1+ i)
j (- j)
joint0 (nth (1- i) joints)
joint1 (nth i joints)
sp (polar joint0 (angle ep1 sp1) (* 0.5 extension))
ep (polar joint1 (angle sp1 ep1) (* 0.5 extension))
sp (polar sp (+ (angle sp1 ep1) (/ pi 2.)) (* j gap))
ep (polar ep (+ (angle sp1 ep1) (/ pi 2.)) (* j gap))
)
;break purlin here
(entmake (_newline sp ep))
)
)
;(setq pointlist (append pointlist (list ep21)))
(if (> (length joints) 2)(entdel purlin))
)
;---------------------------------------------------------------
(defun C:LAQ ()
;upgrade LL command to a VB.NET command
;that quickly turn layer on off, using a floating window palette
(princ)
)
;-------------------------------------
(defun l+transC2W (point vector /)
(trans point 1 0 vector)
)
;-------------------------------------
(defun l+transW2C (point vector /)
(trans point 0 1 vector)
)
;-------------------------------------
(defun l+DimScale ()
(if (= 1 (getvar "DimAnno"))
(/ 1 (getvar "cannoscalevalue"))
(getvar "DimScale")
)
)
;-------------------------------------
(defun l+DimTextHeight (/ dimscale txtstyle dimtxt)
(setq txtStyle (tblsearch "STYLE" (getvar "DIMTXSTY"))
dimtxt (cdr(assoc 40 txtstyle))
)
(if (= dimtxt 0)
(setq dimtxt (getvar "DIMTXT")
dimscale (l+DimScale)
)
(setq dimscale 1)
)
(if (= 0 dimscale) dimtxt (* dimscale dimtxt))
)
;;;-----BEGIN-SIGNATURE-----
;;; DgcAADCCBwoGCSqGSIb3DQEHAqCCBvswggb3AgEBMQ8wDQYJKoZIhvcNAQELBQAw
;;; CwYJKoZIhvcNAQcBoIIFHDCCBRgwggQAoAMCAQICEAEGvWx5L7I4NO7cbDVLRR0w
;;; DQYJKoZIhvcNAQELBQAwcjELMAkGA1UEBhMCVVMxFTATBgNVBAoTDERpZ2lDZXJ0
;;; IEluYzEZMBcGA1UECxMQd3d3LmRpZ2ljZXJ0LmNvbTExMC8GA1UEAxMoRGlnaUNl
;;; cnQgU0hBMiBBc3N1cmVkIElEIENvZGUgU2lnbmluZyBDQTAeFw0xNzA1MDkwMDAw
;;; MDBaFw0yMDA1MDgxMjAwMDBaMFUxCzAJBgNVBAYTAlZOMQ4wDAYDVQQHEwVIYW5v
;;; aTEaMBgGA1UEChMRUGhhbSBWdSBIb25nIExpbmgxGjAYBgNVBAMTEVBoYW0gVnUg
;;; SG9uZyBMaW5oMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAyKCvHYb8
;;; rfskRP+fRRHZqk7Jhdr4vbSheEq1kyurn2c0kzCl9gsagrl8ezubgLnPJhmNoN5p
;;; t+jzqoFwk7Qr/eYbJfbAnt9SIBTtMJRmz+yzHlJv9qVRd7LOnAzsoKWFqQlbUnkE
;;; bHNlnbGJZKra6MUVUeQcxRnAchGFpZM1mPhGwMMItNFPgX3lA+F7/09GurIp3ZIp
;;; sqGknNDP3UWu5demo5NUTewp7vGH5oDdzznjUbt9vO3EYlDJJIuW3IE70QHaZALb
;;; QN7gfEKbDqy6rqrgibgSiGDG+x3jHEOeOmiEC1Mze6snrOXUikK1bRV81q+XLGFi
;;; 4PNaLTppBWVvJQIDAQABo4IBxTCCAcEwHwYDVR0jBBgwFoAUWsS5eyoKo6XqcQPA
;;; YPkt9mV1DlgwHQYDVR0OBBYEFDjftx8saJARHFT9Ba8qjR6fA0l/MA4GA1UdDwEB
;;; /wQEAwIHgDATBgNVHSUEDDAKBggrBgEFBQcDAzB3BgNVHR8EcDBuMDWgM6Axhi9o
;;; dHRwOi8vY3JsMy5kaWdpY2VydC5jb20vc2hhMi1hc3N1cmVkLWNzLWcxLmNybDA1
;;; oDOgMYYvaHR0cDovL2NybDQuZGlnaWNlcnQuY29tL3NoYTItYXNzdXJlZC1jcy1n
;;; MS5jcmwwTAYDVR0gBEUwQzA3BglghkgBhv1sAwEwKjAoBggrBgEFBQcCARYcaHR0
;;; cHM6Ly93d3cuZGlnaWNlcnQuY29tL0NQUzAIBgZngQwBBAEwgYQGCCsGAQUFBwEB
;;; BHgwdjAkBggrBgEFBQcwAYYYaHR0cDovL29jc3AuZGlnaWNlcnQuY29tME4GCCsG
;;; AQUFBzAChkJodHRwOi8vY2FjZXJ0cy5kaWdpY2VydC5jb20vRGlnaUNlcnRTSEEy
;;; QXNzdXJlZElEQ29kZVNpZ25pbmdDQS5jcnQwDAYDVR0TAQH/BAIwADANBgkqhkiG
;;; 9w0BAQsFAAOCAQEA6QPMhqJZllxqUlCTUFAu5snQof8b2rz5LXmI9YBTKz6I+iJz
;;; MPGCJ3CoWrIfciB8QDJmRCrkdO0yR8OLZkux1Le/kcTa+SVBcBGyFsyWacP/55Xe
;;; eCUpZJAHnQgW3nUqmZwxCxRTJf+ybkBLuSov/DtQzH+a1veGuzl/uVGQMnHuKTxD
;;; RmyOwlt61nTssOH9t/DC04Ju4MH062/WMODr/ZBBBLMZ+eZzo0G3LjGdsRikJ6ST
;;; ZMbx51SfbLWmr6z/2vXkvGfNOTLUfjMv/kmOYzXzrw0o+Ayl7IfFe7uH7Wh4e0Z6
;;; AoAzNWAmNLvzDaKIrcrYnqjIJlYehFtiAiN5jzGCAbIwggGuAgEBMIGGMHIxCzAJ
;;; BgNVBAYTAlVTMRUwEwYDVQQKEwxEaWdpQ2VydCBJbmMxGTAXBgNVBAsTEHd3dy5k
;;; aWdpY2VydC5jb20xMTAvBgNVBAMTKERpZ2lDZXJ0IFNIQTIgQXNzdXJlZCBJRCBD
;;; b2RlIFNpZ25pbmcgQ0ECEAEGvWx5L7I4NO7cbDVLRR0wDQYJKoZIhvcNAQELBQAw
;;; DQYJKoZIhvcNAQEBBQAEggEApgLUkqwrb2TOjTzwijX/4DmEnxJBVWpq0AccQL9I
;;; gCl6jSGIsCtmy0Ja03ftIV7WrdhbegkoDrddrmAtYBq4bwZuwm3dzjUP7g6UiG4K
;;; lkw6SxqYohIxB5eJI2TdYuuDet2ooWrTcKueATIRZUxincYb3cXNh3m1q0hdfYeY
;;; 3lBN2D9Y7g+djvGCdgS2WLyhH1uHINYq5eoOoXLVYtlYlLgwvtoEdKerXaHL6sdu
;;; VbZmKxmdWwr3jNl5LVM4/57RtppnJKIfYdx+DX5wsiyZnoVKuKSh5WIvydvCBArn
;;; VftA44Z2G3jpwloeRq7LZ+soRNswp6TAAjh28MJEdUQiUg==
;;; -----END-SIGNATURE-----